home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / database / randomfa / address.bas < prev    next >
Encoding:
BASIC Source File  |  1995-12-29  |  6.1 KB  |  191 lines
  1. Option Explicit
  2.  
  3. ' Define a data type to hold a record:
  4. ' Define global variables to hold the file number and record number
  5. ' of the current data file.
  6. ' Default file name to show in dialog boxes.
  7. Type udtRecord
  8.     AccountNumber   As Long
  9.     Status          As String * 1
  10.     Forename        As String * 12
  11.     Surname         As String * 12
  12.     Company         As String * 30
  13.     Address1        As String * 30
  14.     Address2        As String * 30
  15.     Address3        As String * 30
  16.     PostCode        As String * 15
  17.     Telephone       As String * 15
  18.     Fax             As String * 15
  19.     EMail           As String * 15
  20. End Type
  21.  
  22. Global Const MAX_DATAFIELDS = 12      'Make this equal to the number of fields in the udtRecord structure
  23. Global Const MAX_RECORDS = 2147483647
  24.  
  25.  
  26. Global Const SAVEFILE = 1, LOADFILE = 2
  27. Global Const REPLACEFILE = 1, READFILE = 2, ADDTOFILE = 3
  28. Global Const RANDOMFILE = 4, BINARYFILE = 5
  29.  
  30. Global Const Err_DeviceUnavailable = 68
  31. Global Const Err_DiskNotReady = 71, Err_FileAlreadyExists = 58
  32. Global Const Err_TooManyFiles = 67, Err_RenameAcrossDisks = 74
  33. Global Const Err_Path_FileAccessError = 75, Err_DeviceIO = 57
  34. Global Const Err_DiskFull = 61, Err_BadFileName = 64
  35. Global Const Err_BadFileNameOrNumber = 52, Err_FileNotFound = 53
  36. Global Const Err_PathDoesNotExist = 76, Err_BadFileMode = 54
  37. Global Const Err_FileAlreadyOpen = 55, Err_InputPastEndOfFile = 62
  38. Global Const MB_EXCLAIM = 48, MB_STOP = 16
  39.  
  40. 'From CONSTANT.TXT
  41. ' Colors
  42. Global Const BLACK = &H0&
  43. Global Const RED = &HFF&
  44. Global Const GREEN = &HFF00&
  45. Global Const YELLOW = &HFFFF&
  46. Global Const BLUE = &HFF0000
  47. Global Const MAGENTA = &HFF00FF
  48. Global Const CYAN = &HFFFF00
  49. Global Const WHITE = &HFFFFFF
  50.  
  51. Global Const WM_USER = &H400
  52. Global Const LB_SETTABSTOPS = WM_USER + 19
  53.  
  54. Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
  55. 'SendMessage used here to create our own tab stops in the lstResults ListBox
  56.  
  57. Function ExtractElement (TheString As String, TheElement As Integer) As String
  58.     Dim strSource       As String
  59.     Dim intElement      As Integer
  60.     Dim intCount        As Integer
  61.     Dim intPos          As Integer
  62.     Dim strTab          As String
  63.     strTab = Chr$(9)
  64.     strSource = TheString
  65.     intElement = TheElement
  66.     intPos = InStr(strSource, strTab)
  67.     While intPos > 0
  68.     If intCount = intElement Then
  69.         ExtractElement = Left$(strSource, intPos - 1)
  70.         Exit Function
  71.     Else
  72.         strSource = Mid$(strSource, intPos + 1)
  73.     End If
  74.     intPos = InStr(strSource, strTab)
  75.     intCount = intCount + 1
  76.     Wend
  77. End Function
  78.  
  79. Function FileErrors (errVal As Integer) As Integer
  80.     ' Return Value  Meaning
  81.     ' 0             Resume
  82.     ' 1             Resume Next
  83.     ' 2             Unrecoverable error
  84.     ' 3             Unrecognized error
  85.     Dim MsgType     As Integer
  86.     Dim Response    As Integer
  87.     Dim Action      As Integer
  88.     Dim Msg         As String
  89.     
  90.     MsgType = MB_EXCLAIM
  91.     Select Case errVal
  92.     Case Err_DeviceUnavailable  ' Error #68
  93.         Msg = "That device appears to be unavailable."
  94.         MsgType = MB_EXCLAIM + 5
  95.     Case Err_DiskNotReady       ' Error #71
  96.         Msg = "The disk is not ready."
  97.     Case Err_DeviceIO
  98.         Msg = "The disk is full."
  99.     Case Err_BadFileName, Err_BadFileNameOrNumber   ' Errors #64 & 52
  100.         Msg = "That file name is illegal."
  101.     Case Err_PathDoesNotExist                        ' Error #76
  102.         Msg = "That path doesn't exist."
  103.     Case Err_BadFileMode                            ' Error #54
  104.         Msg = "Can't open your file for that type of access."
  105.     Case Err_FileAlreadyOpen                        ' Error #55
  106.         Msg = "That file is already open."
  107.     Case Err_InputPastEndOfFile                     ' Error #62
  108.         Msg = "This file has a nonstandard end-of-file marker,"
  109.         Msg = Msg + "or an attempt was made to read beyond "
  110.         Msg = Msg + "the end-of-file marker."
  111.     Case Else
  112.         FileErrors = 3
  113.         Exit Function
  114.     End Select
  115.     Response = MsgBox(Msg, MsgType, "File Error")
  116.     Select Case Response
  117.         Case 4          ' Retry button.
  118.         FileErrors = 0
  119.         Case 5          ' Ignore button.
  120.         FileErrors = 1
  121.         Case 1, 2, 3    ' Ok and Cancel buttons.
  122.         FileErrors = 2
  123.         Case Else
  124.         FileErrors = 3
  125.     End Select
  126. End Function
  127.  
  128. Function FileOpener (NewFileName As String, Mode As Integer, RecordLen As Integer, Confirm As Integer) As Integer
  129.      Dim NewFileNum         As Integer
  130.      Dim Action             As Integer
  131.      Dim FileExists         As Integer
  132.      Dim Msg                As String
  133.      
  134.      On Error GoTo OpenerError
  135.      If NewFileName Like "*[;-?[* ]*" Or NewFileName Like "*]*" Then Error Err_BadFileName
  136.      If Confirm Then
  137.     If Dir(NewFileName) = "" Then
  138.         FileExists = False
  139.     Else
  140.         FileExists = True
  141.     End If
  142.     If Mode = REPLACEFILE And FileExists Then
  143.         Msg = "Replace contents of " + NewFileName + "?"
  144.         If MsgBox(Msg, 49, "Replace File?") = 2 Then
  145.         FileOpener = 0
  146.         Exit Function
  147.         End If
  148.     End If
  149.     If Not FileExists Then
  150.         Msg = "The file " + NewFileName + " does not exist. "
  151.         Msg = Msg + "Do you want to create it?"
  152.         If MsgBox(Msg, 1, "Create File?") = 2 Then
  153.         FileOpener = 0
  154.         Exit Function
  155.         End If
  156.     End If
  157.      End If
  158.      NewFileNum = FreeFile
  159.      Select Case Mode
  160.       Case REPLACEFILE
  161.         Open NewFileName For Output As NewFileNum
  162.       Case READFILE
  163.         Open NewFileName For Input As NewFileNum
  164.       Case ADDTOFILE
  165.         Open NewFileName For Append As NewFileNum
  166.       Case RANDOMFILE
  167.         Open NewFileName For Random As NewFileNum Len = RecordLen
  168.       Case BINARYFILE
  169.         Open NewFileName For Binary As NewFileNum
  170.       Case Else
  171.         Exit Function
  172.      End Select
  173.      FileOpener = NewFileNum
  174. Exit Function
  175.  
  176. OpenerError:
  177.      Action = FileErrors(Err)
  178.      Select Case Action
  179.     Case 0
  180.         Resume
  181.     Case Else
  182.         FileOpener = 0
  183.         Exit Function
  184.      End Select
  185. End Function
  186.  
  187. Function GetFilename (Prompt As String, TheDefault As String) As String
  188.     GetFilename = LTrim$(RTrim$(UCase$(InputBox$(Prompt, "Enter File Name", TheDefault))))
  189. End Function
  190.  
  191.